home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0117_Pcx Bitmap Rotating.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-24  |  17KB  |  757 lines
  1. { ROTATE.PAS }
  2.  
  3. {
  4.   Rotating textured surface.
  5.   Coded by Mike Shirobokov(MSH) aka Mad Max / Queue members.
  6.   You can do anything with this code until this comments
  7.   remain unchanged.
  8.  
  9.   Bugs corrected by Alex Grischenko
  10. }
  11.  
  12. {$G+,A-,V-,X+}
  13. {$M 16384,0,16384}
  14.  
  15. uses Crt, Objects, Memory, VgaGraph;  { unit code at the end of program }
  16.  
  17. const
  18. { Try to play with this constants }
  19.   RotateSteps  = {64*5}65*10;
  20.   AngleStep    = {3}1;
  21.   MoveStep     = {10}1;
  22.   ScaleStep    : Real =  0.02;
  23.  
  24. type
  25.   TBPoint = record X,Y: { Byte} Integer; end;
  26.   TPointArray = array[ 1..500 ] of TBPoint;
  27.  
  28.   TRotateApp = object(TGraphApplication)
  29.     StartTime,
  30.     FramesNumber:LongInt;
  31.     {Texture: TImage;}
  32.     X,Y    : Integer;
  33.     WSX,WSY: Integer;
  34.     WSXR,
  35.     WSYR   : Real;
  36.     Angle  : Integer;
  37.     Size   : TPoint;
  38.     CurPage: Integer;
  39.     Texture: TImage;
  40.     constructor Init;
  41.     procedure Run;      virtual;
  42.     destructor Done;    virtual;
  43.     procedure Draw;     virtual;
  44.     procedure FlipPage; virtual;
  45.     procedure Rotate( AngleStep: Integer );
  46.     procedure Move( DeltaX, DeltaY: Integer );
  47.     procedure Scale( Factor: Real );
  48.     procedure Update;
  49.   end;
  50. var
  51.   Pal:  TRGBPalette;
  52.   Time:  LongInt absolute $0:$46C;
  53.  
  54. procedure TRotateApp.FlipPage;
  55. begin
  56.   CurPage := 1-CurPage;
  57.   ShowPage(1-CurPage);
  58. end;
  59.  
  60. constructor TRotateApp.Init;
  61. var
  62.   I, J: Integer;
  63. begin
  64.   if not inherited Init(True) or not Texture.Load( ParamStr(1) ) then Fail;
  65.   SetPalette( Texture.Palette );
  66.   X := 0;
  67.   Y := 0;
  68.   WSX := 240;
  69.   WSY := 360;
  70.   WSXR := WSX;
  71.   WSYR := WSY;
  72.   Angle := 0;
  73.   Size.X := HRes div 2;
  74.   Size.Y := VRes div 2;
  75.   FramesNumber := 0;
  76.   StartTime := Time;  {     asm mov ax,13h; int 10h; end;}
  77.   system.move (Texture.Data^,Screen,64000);
  78.     SetPalette( Texture.Palette );
  79. {  readkey;}
  80. end;
  81.  
  82. procedure TRotateApp.Rotate( AngleStep: Integer );
  83. begin
  84.   Inc( Angle, AngleStep );
  85.   Angle := Angle mod RotateSteps;
  86. end;
  87.  
  88. procedure TRotateApp.Move( DeltaX, DeltaY: Integer );
  89. begin
  90.   Inc( X, DeltaX );
  91.   Inc( Y, DeltaY );
  92. end;
  93.  
  94. procedure TRotateApp.Scale( Factor: Real );
  95. begin
  96.   WSXR := WSXR*Factor;
  97.   WSX := Round(WSXR);
  98.   WSYR := WSYR*Factor;
  99.   WSY := Round(WSYR);
  100. end;
  101.  
  102. procedure TRotateApp.Update;
  103. begin
  104.   Move( MoveStep, MoveStep );
  105.   Rotate(AngleStep);
  106.   Scale(1+ScaleStep);
  107.   if (WSY >= 2000) or (WSY<=100) then ScaleStep := -ScaleStep;
  108. end;
  109.  
  110. procedure TRotateApp.Draw;
  111.  
  112. var
  113.   I :  Integer;
  114.   Border,
  115.   LineBuf: TPointArray;
  116.   BorderLen: Integer;
  117.   X1RN,X1LN,
  118.   Y1RN,Y1LN,
  119.   X2RN,X2LN,
  120.   Y2RN,Y2LN,
  121.   X1R,X1L,
  122.   Y1R,Y1L,
  123.   X2R,X2L,
  124.   Y2R,Y2L,
  125.   XL,YL: Integer;
  126.  
  127. { This function can be heavly optimized but I'm too lazy to do absoletely
  128.   meaningless things :-) }
  129. function BuildLine( var Buffer: TPointArray; X1,Y1, X2,Y2: Integer;
  130.       Len: Integer ): Integer;
  131. var
  132.   I: Word;
  133.   XStep,
  134.   YStep: LongInt;
  135. begin
  136.   XStep := (LongInt(X2-X1) shl 16) div Len;
  137.   YStep := (LongInt(Y2-Y1) shl 16) div Len;
  138.   for I := 1 to Len do
  139.   begin
  140.     Buffer[I].X := Integer( ((XStep*I) shr 16) - ((XStep*(I-1)) shr 16) );
  141.     Buffer[I].Y := Integer( ((YStep*I) shr 16) - ((YStep*(I-1)) shr 16) );
  142.   end;
  143. end;
  144.  
  145. procedure DrawPicLine( var Buffer; BitPlane: Integer;
  146.         StartX, StartY: Integer; Len: Integer; var LineBuf );
  147. var
  148.   PD :  Pointer;
  149. begin
  150.   PD := Texture.Data;           { pointer to unpacked screen image }
  151.   Port[$3C4] := 2;
  152.   if BitPlane = 0 then
  153.     Port[$3C5] := 3
  154.   else
  155.     Port[$3C5] := 12;
  156.  
  157.   asm
  158.     push  ds
  159.     mov   bx,[StartX]             { bx = StartX }
  160.     mov   dx,[StartY]             { dx = StartY }
  161.     les   di,Buffer               { ES:DI = @Screen }
  162.     add   di,VPageLen/2-Hres/4    { calc target page }
  163.     mov   cx,Len                  { Drawing buffer length }
  164.     lds   si,PD                   { DS:SI = pointer to data }
  165.     push  bp                      { store BP }
  166.     mov   bp,word ptr LineBuf     { BP = offset LineBuf }
  167.     cld
  168. @loop:
  169.       PUSH DX
  170.       MOV  AX,320
  171.       MUL  DX                     { AX = StartY*320 }
  172.       POP  DX
  173.  
  174.       PUSH BX
  175.       ADD  BX,AX
  176.       mov  al,[bx+SI]
  177.       POP  BX
  178.  
  179.       stosb
  180.       sub  di,HRes/4+1{ add di,hres-1}
  181.       add  BX,[bp]
  182.       ADD  bp,2
  183.       add  DX,[bp]
  184.       ADD  bp,2
  185.  
  186. {      CMP  BX,320
  187.       JB   @@1
  188.       XOR  BX,BX
  189. @@1:  CMP  DX,200
  190.       JB   @@2
  191.       XOR  DX,DX
  192. @@2:}
  193.       loop @loop
  194.  
  195.       pop bp
  196.       pop ds
  197.   end;
  198. end;
  199.  
  200. begin
  201.  
  202. { Just imagine what can be if the next 8 lines would be more complex.
  203.   I'm working around it. }
  204. {
  205.      (X1L,Y1L)        (X2R,Y1R)
  206.         +---------------+
  207.         |               |
  208.         |               |
  209.         |               |
  210.         +---------------+
  211.      (X2L,Y2L)        (X2R,Y2R)
  212.  
  213.      (X1LN,Y1LN)        (X2RN,Y1RN)
  214.         +---------------+
  215.         |               |
  216.         |               |
  217.         |               |
  218.         +---------------+
  219.      (X2LN,Y2LN)        (X2RN,Y2RN)
  220.  
  221. }
  222.   X1L := 0;
  223.   Y1L := 0;
  224.   X2L := 0;
  225.   Y2L := WSY;
  226.   X1R := WSX;
  227.   Y1R := 0;
  228.   X2R := WSX;
  229.   Y2R := WSY;
  230. { I call Cos and Sin instead of using tables!? Yeah, I do. So what?
  231.   See comments near BuildLine ;-) }
  232. {  I just rotate the rectangle corners, but why I do no more? }
  233.   X1RN := Round(
  234. (X1R*Cos(2*Pi/RotateSteps*Angle)+Y1R*Sin(2*Pi/RotateSteps*Angle)) );
  235.   Y1RN := Round(
  236. (Y1R*Cos(2*Pi/RotateSteps*Angle)-X1R*Sin(2*Pi/RotateSteps*Angle)) );
  237.   X1LN := Round(
  238. (X1L*Cos(2*Pi/RotateSteps*Angle)+Y1L*Sin(2*Pi/RotateSteps*Angle)) );
  239.   Y1LN := Round(
  240. (Y1L*Cos(2*Pi/RotateSteps*Angle)-X1L*Sin(2*Pi/RotateSteps*Angle)) );
  241.   X2RN := Round(
  242. (X2R*Cos(2*Pi/RotateSteps*Angle)+Y2R*Sin(2*Pi/RotateSteps*Angle)) );
  243.   Y2RN := Round(
  244. (Y2R*Cos(2*Pi/RotateSteps*Angle)-X2R*Sin(2*Pi/RotateSteps*Angle)) );
  245.   X2LN := Round(
  246. (X2L*Cos(2*Pi/RotateSteps*Angle)+Y2L*Sin(2*Pi/RotateSteps*Angle)) );
  247.   Y2LN := Round(
  248. (Y2L*Cos(2*Pi/RotateSteps*Angle)-X2L*Sin(2*Pi/RotateSteps*Angle)) );
  249.  
  250.   XL := X+X1LN;
  251.   YL := Y+Y1LN;
  252.  
  253.   BuildLine( Border, XL,YL, X+X2LN,Y+Y2LN, Size.X );
  254.   BuildLine( LineBuf, 0, 0, X1RN-X1LN, Y1RN-Y1LN, Size.Y );
  255.  
  256. {
  257.   The only thing that can be optimized is the loop below. I think it should
  258.   be completely in asm.
  259. }
  260.   for I := 1 to Size.X do
  261.   begin
  262.    DrawPicLine( PBuffer(@Screen)^[CurPage*VPageLen+(I-1) shr 1],
  263.    (I-1) {mod 2} and 1, XL, YL, Size.Y, LineBuf );
  264. {
  265.     Inc( XL, Border[I].X );
  266.     Inc( YL, Border[I].Y );
  267. }
  268.   asm
  269.     mov   di,I
  270.     shl   di,2
  271.     mov   ax,word ptr border[di]-4
  272.     add   XL,ax
  273.     mov   ax,word ptr Border[di]-4+2
  274.     add   YL,ax
  275.   end;
  276.   end;
  277. end;
  278.  
  279. procedure TRotateApp.Run;
  280. var
  281.   C:  Char;
  282. begin
  283.   repeat
  284.     if KeyPressed then
  285.     begin
  286.       C := ReadKey;
  287.       if C = #0 then C := ReadKey;
  288.       case C of
  289.  #72: Move(0,-10);
  290.  #80: Move(0,-10);
  291.  #75: Move(-10,0);
  292.  #77: Move(10,0);
  293.  #81: Rotate(1);
  294.  #79: Rotate(-1);
  295.  '+': Scale(1+ScaleStep);
  296.  '-': Scale(1-ScaleStep);
  297.  #27: Exit;
  298.       end;
  299.     end;
  300.    Draw;
  301. { You can comment out the line below and do all transformation yourself }
  302.    Update;
  303.    FlipPage;
  304.    Inc( FramesNumber );
  305.   until False;
  306. end;
  307.  
  308. destructor TRotateApp.Done;
  309. begin
  310.   inherited Done;
  311.   WriteLn( 'Frames per second = ',
  312.     (FramesNumber / ((Time-StartTime)*0.055) ):5:2 );
  313. end;
  314.  
  315. var
  316.   RotateApp: TRotateApp;
  317. begin
  318.   if not RotateApp.Init then Exit;
  319.   RotateApp.Run;
  320.   RotateApp.Done;
  321. end.
  322.  
  323. {---------------------   UNIT CODE NEEDED HERE -------------------- }
  324.  
  325. {
  326.   VGA graphics unit.
  327.   Coded by Mike Shirobokov(MSH) aka Mad Max / Queue members.
  328.  
  329.   This this the very small part of my gfx unit. I leave only functions used
  330.   by RotateApp.
  331.  
  332.   Bugs corrected by Alex Grischenko
  333. }
  334.  
  335. unit VGAGraph;
  336.  
  337. interface
  338.  
  339. uses Objects, Memory;
  340.  
  341. const
  342.   HRes  = 360;
  343.   VRes  = 320;
  344.   VPageLen = HRes*VRes div 4;
  345.  
  346. {  HRes = 320; VRes=200; Vpagelen=0;}
  347.  
  348. type
  349.   PBuffer = ^TBuffer;
  350.   TBuffer = array[ 0..65534 ] of Byte;
  351.   PScreenBuffer = ^TScreenBuffer;
  352.   TScreenBuffer = array[ 0..199, 0..319 ] of Byte;
  353.   TRGBPalette = array[ 0..255 ] of record R,G,B: Byte; end;
  354.  
  355.   PImage = ^TImage;
  356.   TImage = object( TObject )
  357.     Size: TPoint;
  358.     Palette: TRGBPalette;
  359.     Data: PBuffer;
  360.     constructor Load( Name: String );
  361. {   This procedures are now killed. If you need them just write me or see
  362.     old mail from me.
  363.     procedure Show( Origin: TPoint; var Buffer );
  364.     procedure ShowRect( Origin: TPoint; NewSize: TPoint; var Buffer ); }
  365.     destructor Done; virtual;
  366.   end;
  367.  
  368.   PGraphApplication = ^TGraphApplication;
  369.   TGraphApplication = object( TObject )
  370.     constructor Init( ModeX : Boolean );
  371.     procedure Run; virtual;
  372.     destructor Done; virtual;
  373.   end;
  374.  
  375. var
  376.   Screen: TScreenBuffer absolute $A000:0;
  377.  
  378.   procedure SetPalette( var Pal: TRGBPalette );
  379.   procedure Set360x240Mode;
  380.   procedure ShowPage( Page: Integer );
  381.  
  382. implementation
  383.  
  384. uses PCX;
  385.  
  386. constructor TImage.Load( Name: String );
  387. var
  388.   S: TDosStream;
  389.   I: Integer;
  390.   P: OldPCXPicture;
  391.   Len: Word;
  392. begin
  393.   inherited Init;
  394.   P.Init( Name );
  395.   if P.Status <> pcxOK then
  396.   begin
  397.     P.Done;
  398.     Fail;
  399.   end;
  400.   Size.X := P.H.XMax - P.H.XMin + 1;
  401.   Size.Y := P.H.YMax - P.H.YMin + 1;
  402. {
  403.   I use DOS memory allocation 'cuz GetMem can't allocate 64K
  404.   Even thru DPMI.  :-(
  405.   GetMem( Data, Word(Size.X) * Size.Y );
  406. }
  407.   Len := Word((LongInt(Size.X)*Size.Y+15) div 16);
  408.   LEN:=65536 DIV 16;
  409.   asm
  410.     mov ah,48h
  411.     mov bx,Len
  412.     int 21h
  413.     jnc @mem_ok
  414.     xor ax,ax
  415. @mem_ok:
  416.     mov word ptr es:[di].Data+2,ax
  417.     xor ax,ax
  418.     mov word ptr es:[di].Data,ax
  419.   end;
  420.  
  421.   if Data = nil then
  422.   begin
  423.     P.Done;
  424.     Fail;
  425.   end;
  426.  
  427.   fillchar(Data^,len*16-1,0);
  428.  
  429.   Move( P.Pal, Palette, SizeOf(Palette) );
  430.   for I := 0 to 255 do
  431.   begin
  432.     Palette[I].R := Palette[I].R shr 2;
  433.     Palette[I].G := Palette[I].G shr 2;
  434.     Palette[I].B := Palette[I].B shr 2;
  435.   end;
  436.  
  437.   for I := 0 to Size.Y-1 do
  438.     P.ReadLine( Data^[ Word(Size.X)*I ] );
  439.   P.Done;
  440. end;
  441.  
  442. destructor TImage.Done;
  443. begin
  444. {
  445.   FreeMem( Data, Word(Size.X)*Size.Y );
  446. }
  447.   asm
  448.     mov ah,49h
  449.     mov ax,word ptr es:[di].Data+2
  450.     mov es,ax
  451.     int 21h
  452.   end;
  453.   inherited Done;
  454. end;
  455.  
  456. constructor TGraphApplication.Init( ModeX : Boolean );
  457. begin
  458.   Set360x240Mode
  459. end;
  460.  
  461. procedure TGraphApplication.Run;
  462. begin
  463.   Abstract;
  464. end;
  465.  
  466. destructor TGraphApplication.Done;
  467. begin
  468.   asm
  469.     mov ax,3h
  470.     int 10h
  471.   end;
  472. end;
  473.  
  474. procedure SetPalette( var Pal: TRGBPalette );
  475. var
  476.   I : Integer;
  477. begin
  478.   for I := 0 to 255 do
  479.   begin
  480.     Port[$3C8] := I;
  481.     Port[$3C9] := Pal[I].R;
  482.     Port[$3C9] := Pal[I].G;
  483.     Port[$3C9] := Pal[I].B;
  484.   end;
  485. end;
  486.  
  487. {  Modified from public-domain mode set code by John Bridges. }
  488.  
  489. const
  490.  SC_INDEX  = $03c4;   {Sequence Controller Index}
  491.  CRTC_INDEX = $03d4;   {CRT Controller Index}
  492.  MISC_OUTPUT  = $03c2;   {Miscellaneous Output register}
  493.  
  494. { Index/data pairs for CRT Controller registers that differ between
  495.   mode 13h and mode X. }
  496.  
  497. CRT_PARM_LENGTH = 17;
  498. CRTParms : array [1..CRT_PARM_LENGTH] of Word = (
  499.  
  500.  $6B00,  { Horz total }
  501.  $5901,  { Horz Displayed }
  502.  $5A02,  { Start Horz Blanking }
  503.  $8E03,  { End Horz Blanking }
  504.  $5E04,  { Start H Sync }
  505.  $8A05,  { End H Sync }
  506.  $0d06,  {vertical total}
  507.  $3e07,  {overflow (bit 8 of vertical counts)}
  508.  $ea10,  {v sync start}
  509.  $8c11,  {v sync end and protect cr0-cr7}
  510.  $df12,  {vertical displayed}
  511.  $e715,  {v blank start}
  512.  $0616,  {v blank end}
  513.  $4209,  {cell height (2 to double-scan)}
  514.  $0014,  {turn off dword mode}
  515.  $e317,  {turn on byte mode}
  516.  $2D13 {90 bytes per line}
  517. );
  518.  
  519. procedure Set360x240Mode;
  520. begin
  521.  asm
  522.  mov     ax,13h  {let the BIOS set standard 256-color}
  523.  int     10h     {mode (320x200 linear)}
  524.  
  525.  mov     dx,SC_INDEX
  526.  mov     ax,0604h
  527.  out     dx,ax   {disable chain4 mode}
  528.  mov     ax,0100h
  529.  out     dx,ax   {synchronous reset while switching clocks}
  530.  
  531.  mov     dx,MISC_OUTPUT
  532.  mov     al,0E7h
  533.  out     dx,al   {select 28 MHz dot clock & 60 Hz scanning rate}
  534.  
  535.  mov     dx,SC_INDEX
  536.  mov     ax,0300h
  537.  out     dx,ax   {undo reset (restart sequencer)}
  538.  
  539.  mov     dx,CRTC_INDEX {reprogram the CRT Controller}
  540.  mov     al,11h  {VSync End reg contains register write}
  541.  out     dx,al   {protect bit}
  542.  inc     dx      {CRT Controller Data register}
  543.  in      al,dx   {get current VSync End register setting}
  544.  and     al,7fh  {remove write protect on various}
  545.  out     dx,al   {CRTC registers}
  546.  dec     dx      {CRT Controller Index}
  547.  cld
  548.  mov     si,offset CRTParms {point to CRT parameter table}
  549.  mov     cx,CRT_PARM_LENGTH {# of table entries}
  550. @SetCRTParmsLoop:
  551.  lodsw           {get the next CRT Index/Data pair}
  552.  out     dx,ax   {set the next CRT Index/Data pair}
  553.  push cx
  554.  mov cx,1000
  555. @loop: loop @loop
  556.  pop cx
  557.  loop    @SetCRTParmsLoop
  558.  
  559.  mov     dx,SC_INDEX
  560.  mov     ax,0f02h
  561.  out     dx,ax   {enable writes to all four planes}
  562.  mov     ax,$A000{now clear all display memory, 8 pixels}
  563.  mov     es,ax         {at a time}
  564.  sub     di,di   {point ES:DI to display memory}
  565.  sub     ax,ax   {clear to zero-value pixels}
  566.  mov     cx,VRes*HRes/4/2 {# of words in display memory}
  567.  rep     stosw   {clear all of display memory}
  568.  end;
  569. end;
  570.  
  571. procedure ShowPage( Page: Integer );
  572. begin
  573.   asm
  574.       mov ax,VPageLen
  575.       mul word ptr Page
  576.       mov bx,ax
  577.  
  578.       mov dx,3d4h
  579.       mov al,0ch
  580.       mov ah,bh
  581.       out dx,ax
  582.       mov dx,3d4h
  583.       mov al,0dh
  584.       mov ah,bl
  585.       out dx,ax
  586. { Uncomment this waiting for retrace if you see flickering }
  587. {
  588.       mov dx,3dah
  589.  @@1: in al,dx
  590.       test al,00001000b
  591.       jz @@1
  592.  @@2: in   al,dx
  593.       test al,00001000b
  594.       jnz  @@2
  595. }
  596.   end;
  597. end;
  598.  
  599. End.
  600.  
  601. { --------------------------  UNIT CODE NEEDED HERE -------------}
  602.  
  603. {
  604.   256 color PCX bitmaps handling unit.
  605.   NewPCXPicture object are removed to reduce traffic. If you
  606.   need it just contact me or dig in old mail from me.
  607.   Coded by Mike Shirobokov(MSH) aka Mad Max / Queue Members.
  608.   Free sourceware.
  609. }
  610.  
  611. unit PCX;
  612.  
  613. interface
  614.  
  615. uses Objects;
  616.  
  617. type
  618.   TRGBPalette = array[ 0..255 ] of record R,G,B: Byte; end;
  619.  
  620.   PCXHeader = record
  621.     Creator,
  622.     Version,
  623.     Encoding,
  624.     Bits: Byte;
  625.     XMin,
  626.     YMin,
  627.     XMax,
  628.     YMax,
  629.     HRes,
  630.     VRes: Integer;
  631.     Palette: array [ 1..48 ] of Byte;
  632.     VMode,
  633.     Planes: Byte;
  634.     BytesPerLine,
  635.     PaletteInfo,
  636.     SHRes,
  637.     SVRes: Word;
  638.     Dummy: array [0..53] of Byte;
  639.   end;
  640.  
  641. const
  642.   pcxOK   = 0;
  643.   pcxInvalidType = 1;
  644.   pcxNoFile  = 2;
  645.  
  646. type
  647.   OldPCXPicture = object
  648.     H:  PCXHeader;
  649.     S:  TBufStream;
  650.     Pal: TRGBPalette;
  651.     Status: Integer;
  652.     constructor Init( AFileName: String );
  653.     procedure ReadLine( var Buffer );
  654.     function ErrorText: String;
  655.     destructor Done;
  656.   end;
  657. {
  658.   NewPCXPicture = object
  659.     H:  PCXHeader;
  660.     S:  TBufStream;
  661.     Pal: TRGBPalette;
  662.     constructor Init( AFileName: String; HSize: Integer );
  663.     procedure WriteLine( var Buffer );
  664.     destructor Done;
  665.   end;
  666. }
  667. implementation
  668.  
  669. type
  670.   GetByteFunc = function: Byte;
  671.   ByteArr = array [0..65534] of Byte;
  672.   PByte  = ^ByteArr;
  673.  
  674. procedure UnpackString( GetByte: GetByteFunc; var Dest; Size: Integer );
  675. var
  676.   DestPtr: PByte;
  677.   Count: Integer;
  678.   B:  Byte;
  679.   I:  Integer;
  680. begin
  681.   DestPtr := @Dest;
  682.   Count := 0;
  683.   while Count < Size do
  684.   begin
  685.     B := GetByte;
  686.     if B < $C0 then
  687.     begin
  688.       DestPtr^[Count] := B;
  689.       Inc(Count);
  690.     end
  691.     else
  692.     begin
  693.       DestPtr^[Count] := GetByte;
  694.       for I := 0 to B-$C1 do
  695.  DestPtr^[Count+I] := DestPtr^[Count];
  696.       Inc( Count, I+1 );
  697.     end;
  698.   end;
  699. end;
  700.  
  701. constructor OldPCXPicture.Init( AFileName: String );
  702. begin
  703.   S.Init( AFileName, stOpenRead, 2048 );
  704.   if S.Status <> stOk then
  705.   begin
  706.     Status := pcxNoFile;
  707.     Exit;
  708.   end;
  709.   S.Read( H, SizeOf(H) );
  710.   if (H.Planes <> 1) or (H.Encoding <> 1) or (H.Bits <> 8 ) then
  711.   begin
  712.     Status := pcxInvalidType;
  713.     Exit;
  714.   end;
  715.   S.Seek( S.GetSize - SizeOf(Pal) );
  716.   S.Read( Pal, SizeOf(Pal) );
  717.   S.Seek( SizeOf(H) );
  718.   Status := pcxOK;
  719. end;
  720.  
  721. var
  722.   __GetS__: PStream;
  723.  
  724. function Get: Byte; far;
  725. var
  726.   B: Byte;
  727. begin
  728.   __GetS__^.Read( B, 1 );
  729.   Get := B;
  730. end;
  731.  
  732. procedure OldPCXPicture.ReadLine( var Buffer );
  733. begin
  734.   __GetS__ := @S;
  735.   UnpackString( Get, Buffer, H.BytesPerLine );
  736. end;
  737.  
  738. function OldPCXPicture.ErrorText: String;
  739. begin
  740.   case Status of
  741.     pcxOK:
  742.       ErrorText := 'No errors';
  743.     pcxNoFile:
  744.       ErrorText := 'Can''t open file';
  745.     pcxInvalidType:
  746.       ErrorText := 'Only 8 bit PCXs are supported';
  747.   end;
  748. end;
  749.  
  750. destructor OldPCXPicture.Done;
  751. begin
  752.   S.Done;
  753. end;
  754.  
  755. end.
  756.  
  757.